perm filename 12T.F4[12T,LCS] blob
sn#637500 filedate 1982-01-27 generic text, type T, neo UTF8
C ********** MATRIX FEB. 16,73 ******** PRINTS 12-TONE CHART ******
C ***** LOAD WITH 12TSUB.F4 *********
C 'S'EARCH WILL LOCATE ROW SOURCES OF CHORDS, ETC.
COMMON INV(12),IR(12),N(12),J(13,13),ISCAL(12),IS2(12),
1 INP2(72),INP(72),NRW
1,IC(6),ISQ(25,25),NAME(10),INOT(49),JA(12)
DATA ISCAL/'C','C#','D','D#','E','F','F#','G','G#',
1 'A','A#','B'/,INV/'I0','I1','I2','I3','I4','I5','I6','I7',
1 'I8','I9','I10','I11'/,IR/'P0','P1','P2','P3','P4',
1 'P5','P6','P7','P8','P9','P10','P11'/
DATA IS2/'C','$','D','$','E','F','$','G','$','A','$','B'/
C N=NEW ROW, T=TYPE MATRIX, L=LPT, S=SEARCH, R=READ FILE 'ROWS', W=WRITE
662 TYPE 61
ACCEPT 1,NRW
IF(NRW.EQ.'L'.OR.NRW.EQ.'M')GO TO 62
C 'M' IS FOR OUTPUT TO MSS PROG.
IF(NRW.EQ.'T')GO TO 1188
IF(NRW.NE.'R'.AND.NRW.NE.'W')GO TO 6620
CALL RDWRT
C WE'VE JUST READ IN A ROW.
6620 IF(NRW.NE.'S')GO TO 64
663 TYPE 65
GO TO 661
65 FORMAT(' TYPE NOTES'/)
61 FORMAT(/' N=NEW, T=TYPE MTRX, S=SRCH, R=RD, W=WRT, L=LST'/)
300 FORMAT(' PRINT HOW MANY?'/)
200 FORMAT(' TYPE NAME OF WORK'/)
62 KREP=0
TYPE 300
ACCEPT 400,KREP
1188 KREP=KREP-1
JOUT=3
IF(NRW.EQ.'T')JOUT=5
GO TO 288
64 HEX=-10
J(2,1)=INV(1)
J(1,2)=IR(1)
IF(NRW.EQ.'R')GO TO 661
TYPE 200
ACCEPT 444,NAME
188 TYPE 100
661 JOUT=5
FIRST=-1.
IF(NRW.EQ.'R')GO TO 6650
ACCEPT 1,INP2
IF(NRW.EQ.'S')GO TO 498
6650 DO 665 KGZ=1,72
665 INP(KGZ)=INP2(KGZ)
GO TO 198
C IF A 13TH NOTE IS ADDED, THEN NO PRINTOUT.
C TYPE 'S' TO SEARCH, 'SP' OUTPUTS TO LPT.
498 K=0
JS=0
ISQ2=0
298 K=K+1
DID=0
IF(K.GT.72)GO TO 8888
L=INP2(K)
IF(L.EQ.' ')GO TO 298
DO 888 M=1,12
IF(L.NE.IS2(M))GO TO 888
LL=M
K=K+1
IF(INP2(K).EQ.'S')LL=M+1
IF(INP2(K).EQ.'F')LL=M-1
ISQ2=ISQ2+2**LL
C ASSIGNS # TO EACH NOTE
JS=JS+1
C JS IS # OF NOTES IN GROUP TO BE FOUND.
GO TO 298
888 CONTINUE
8888 IF(JS.EQ.0)CALL EXIT
C NO NOTES WERE GIVEN.
IF(FIRST)LGRP=JS
FIRST=0
C SAVE # OF NOTES TO BE FOUND.
JGRP=JS-1
DO 333 NN=1,2
DO 333 K=1,13
C '+JGRP' IS FOR WRAP-AROUND
JQ=2
DO 222 L=1,12
KQ=L
C SETS # OF 1ST NOTE OF FOUND GROUP.
LL=0
DO 223 KK=JQ,JQ+JGRP
NR=KK
NI=K
IF(NN.EQ.1)GO TO 223
NR=K
NI=KK
223 LL=LL+ISQ(NR,NI)
2223 IF(LL.EQ.ISQ2)GO TO 334
222 JQ=JQ+1
GO TO 333
334 NR=1
IF(LGRP.NE.JS)TYPE 67,JS
LGRP=JS
C NN=1, R FORMS. NN=2, I FORMS.
IF(NN.EQ.1)GO TO 2334
NI=1
NR=K
C K WILL BE 1ST NOTE OF GROUP IN ROW.
2334 WRITE(JOUT, 66),J(NR,NI),KQ
DID=-1.
333 CONTINUE
IF(DID)GO TO 3333
IF(JGRP.NE.1)GO TO 3334
C DON'T TRY AGAIN IF GROUP IS DOWN TO 2.
TYPE 67,JGRP
GO TO 3333
3334 DO 398 K=72,1,-1
IF(INP2(K).EQ.' ')GO TO 398
3398 INP2(K)=' '
INP2(K-1)=' '
GO TO 498
398 CONTINUE
C ABOVE SHORTENS GROUP BY ONE.
3333 TYPE 60
GO TO 662
198 JJ=1
K=0
98 K=K+1
IF(K.GT.72)GO TO 9999
L=INP(K)
IF(L.EQ.' ')GO TO 98
IF(JJ.EQ.14)GO TO 99
C ANYTHING TYPED AFTER 12 NOTES CAUSES 'NOPRIN'.
DO 999 M=1,12
IF(L.NE.IS2(M))GO TO 999
LL=M
K=K+1
IF(INP(K).EQ.'S')LL=M+1
IF(INP(K).EQ.'F')LL=M-1
JA(JJ)=LL
C SAVES #S FOR NOTATION
JJ=JJ+1
J(JJ,2)=LL
ISQ(JJ,2)=2**LL
C SETS VALUE AS POWER OF 2 FOR EACH NOTE.
GO TO 98
999 CONTINUE
99 CONTINUE
9999 IF(JJ.EQ.1)CALL EXIT
C NO NOTES WERE GIVEN.
I=J(2,2)
C WORKS OUT MATRIX
DO 9 K=3,13
LL=J(K,2)-I+1
IF(LL.LE.0)LL=LL+12
9 J(K,1)=INV(LL)
DO 2 K=2,12
2 N(K)=J(K+1,2)-I
DO 3 K=3,13
LL=I-N(K-1)
IF(LL.LT.1)LL=LL+12
IF(LL.GT.12)LL=LL-12
ISQ(2,K)=2**LL
J(2,K)=LL
LL=LL+1-I
IF(LL.LE.0)LL=LL+12
3 J(1,K)=IR(LL)
DO 4 K=3,13
DO 4 I=3,13
LL=J(2,I)+N(K-1)
IF(LL.LT.1)LL=LL+12
IF(LL.GT.12)LL=LL-12
ISQ(K,I)=2**LL
4 J(K,I)=ISCAL(LL)
DO 7 K=2,13
7 J(K,2)=ISCAL(J(K,2))
DO 8 K=3,13
8 J(2,K)=ISCAL(J(2,K))
10 J(1,1)=0
DO 28 K=2,13
DO 28 L=2,13
KQ=ISQ(K,L)
ISQ(K+12,L)=KQ
28 ISQ(K,L+12)=KQ
C +12 FOR WRAP-AROUND
288 IF(NRW.EQ.'M')CALL MSS12
C MSS12 MAKES FILE FOR MSS PROG.
WRITE(JOUT, 60),NAME
WRITE(JOUT, 60)
C NEXT JUMPS OVER NOTATION PRINT.
GO TO 5557
C UNTIL 210, PRINTS NOTATION
G=' '
WRITE(JOUT, 201),G
L=5
DO 202 IJ=1,7
LN=-1
IF(IJ.EQ.2.OR.IJ.EQ.4.OR.IJ.EQ.6)LN=0
C LINE OR SPACE
JK=2
IF(IJ.EQ.1.OR.IJ.EQ.4)JK=1
DO 203 IQ=1,JK
204 DO 205 K=1,49
205 INOT(K)=' '
DO 206 K=1,12
IF(JA(K).NE.L)GO TO 206
C SKIPS IF NO NOTE NOW
IK=K
L=L-1
IF(L.EQ.0)L=12
M=K*4-1
IF(IK.GT.6)M=M+2
2000 INOT(M)='O'
IF(L.EQ.3.OR.L.EQ.1.OR.L.EQ.10.OR.L.EQ.8.OR.
1 L.EQ.6)INOT(M-1)='#'
IF(L.EQ.2.OR.L.EQ.12.OR.L.EQ.9.OR.L.EQ.7.OR.
1 L.EQ.5)LN=0
GO TO 208
206 CONTINUE
208 IF(LN)WRITE(JOUT, 209),(INOT(IZ),IZ=1,M)
C OVERPRINTS
203 IF(LN.EQ.0)WRITE(JOUT, 210),(INOT(IZ),IZ=1,M)
G=' '
IF(IJ.EQ.5)G='G'
202 IF(IJ.NE.2.AND.IJ.NE.4.AND.IJ.NE.6)WRITE(JOUT, 201),G
201 FORMAT(2XA1,52('-'))
209 FORMAT(4X49A1)
210 FORMAT('+',4X49A1)
C PRINTS LINES FOR SCRATCH.
5557 WRITE(JOUT, 60)
J(1,1)=' '
WRITE(JOUT, 5),J
CC IF(JOUT.EQ.5)PAUSE
111 CONTINUE
DO 1111 K=1,6
1111 IC(K)=0
LR=1
JGRP=6
KGRP=2
MPRINT=2
DO 1000 IGRP=1,4
KK=0
DO 17 K=1,12,JGRP
JJ=0
DO 117 L=1,JGRP
117 JJ=JJ+ISQ(K+L,2)
KK=KK+1
17 IC(KK)=JJ
MM=0
MCNT=0
DO 19 NN=1,2
JQQ=4-NN
DO 19 I=JQQ,13
DO 21 KK=1,KGRP
DO 18 K=1,12,JGRP
JJ=0
DO 118 L=1,JGRP
NI=I
NR=L+K
IF(NN.EQ.1)GO TO 118
NI=NR
NR=I
118 JJ=ISQ(NR,NI)+JJ
LL=I
GO TO 18
WRITE(JOUT, 400),KK,JGRP,JJ,IGRP,KGRP,K
18 IF(IC(KK).EQ.JJ)GO TO 21
GO TO 19
21 CONTINUE
LI=LL
LR=1
IF(NN.EQ.1)GO TO 221
LI=1
LR=LL
221 IF(MM)GO TO 55
MPRINT=MPRINT+1
C COUNTS FOR STAFF PRINTOUT
GO TO (11,22,33,44),IGRP
11 WRITE(JOUT, 51)
HEX=0
GO TO 55
22 WRITE(JOUT, 52)
HEX=-10
GO TO 55
33 WRITE(JOUT, 53)
HEX=-10
GO TO 55
44 WRITE(JOUT, 54)
HEX=-10
55 MM=-1
IF(HEX.EQ.5)WRITE(JOUT, 51)
HEX=HEX+1
MCNT=MCNT+1
WRITE(JOUT, 50),J(LR,LI)
IF(MCNT.LT.7)GO TO 19
MCNT=0
MM=0
C TO STAY IN 8 1/2" WIDTH ON PAPER
19 CONTINUE
JGRP=JGRP-1
IF(IGRP.EQ.1)JGRP=4
1000 KGRP=12/JGRP
KREP=KREP-1
IF(JOUT.EQ.5)GO TO 662
WRITE(JOUT, 60)
L=5-MPRINT/2
DO 5555 K=1,L
5555 WRITE(JOUT, 5556)
IF(KREP)CALL EXIT
WRITE(JOUT, 500)
GO TO 10
5556 FORMAT(/5(1X,80('-')/)/)
51 FORMAT(/' HEXADS ....P0',$)
52 FORMAT(/' TETRADS ...P0',$)
53 FORMAT(/' TRIADS ....P0',$)
54 FORMAT(/' DYADS .....P0',$)
5 FORMAT(1XA4,2(1X6A4)/2(/6(1XA4,2(1X6A4)/)))
1 FORMAT (72A1)
444 FORMAT (10A5)
50 FORMAT('+ = ',A3,$)
60 FORMAT(1X10A5)
66 FORMAT(1XA5,I2,3XI2)
67 FORMAT(' GROUP SHORTENED TO ',I2)
100 FORMAT(' TYPE 12 NOTES'/)
500 FORMAT('1')
400 FORMAT(6I)
END
SUBROUTINE RDWRT
C TO READ AND RWITE TONE-ROW LIBRARY FILE
COMMON INV(12),IR(12),N(12),J(13,13),ISCAL(12),IS2(12),
1 INP2(72),INP(72),NRW
1,IC(6),ISQ(25,25),NAME(10),INOT(49),JA(12)
15 TYPE 13
ACCEPT 2,NM
REREAD 7,MA
IF(MA.NE.0)GO TO 20
IF(NM.EQ.' ')NM='ROWS'
IF(NRW.EQ.'R')GO TO 1
CC IF(LOOKD(NM))GO TO 1
C 'LOOKD' LOOKS FOR .DAT FILE -- 'LOOK' LOOKS FOR NO EXT.
CALL OFILE(1,NM)
WRITE(1,2)NAME
WRITE(1,3)INP2
END FILE 1
RETURN
2 FORMAT(10A5)
3 FORMAT(72A1)
5 FORMAT(1X10A5)
7 FORMAT(I,10A5)
8 FORMAT(I,72A1)
13 FORMAT(' TYPE FILE NAME -- '$)
10 FORMAT(' TYPE NUMBER -- '$)
11 FORMAT(I3,') ',10A5)
1 CALL IFILE(1,NM)
KA=1
4 READ(1,7,END=9)M,NAME
TYPE 11,KA,NAME
KA=KA+1
READ(1,7,END=9)M,NAME
C READS ROW NOTES.
GO TO 4
20 NM=NMX
GO TO 21
9 TYPE 10
ACCEPT 7,MA
21 IF(MA.LE.0.OR.MA.GT.KA)GO TO 15
CALL IFILE(1,NM)
DO 12 K=1,MA
READ(1,7,END=9)MM,NAME
12 READ(1,8,END=9)MM,INP2
C READS SOS FILES ONLY
C READS ROW NOTES.
NMX=NM
END
SUBROUTINE MSS12
C TO CREATE DATA FOR MSS PROG.
C THIS IS A DUMMY
END